home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power Programmierung
/
Power-Programmierung (Tewi)(1994).iso
/
magazine
/
pctchnqs
/
1991
/
number2
/
fast.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-03-27
|
4KB
|
152 lines
{ fast.pas -- Draw polygon by "blasting" a bitmap }
program Fast;
{$R test.res} { Attach binary resources to .EXE file }
uses WinTypes, WinProcs, WObjects, Poly;
const
id_Menu = 100; { Menu resource ID }
cm_NewShape = 101; { Menu New Shape command ID }
cm_Quit = 102; { Menu Quit command ID }
numShapes = 5; { Number of polygons to display }
type
TestApplication = object(TApplication)
procedure InitMainWindow; virtual;
end;
PTestWindow = ^TestWindow;
TestWindow = object(TWindow)
PolyBits: HBitmap; { Handle to a bitmap }
PolyShapes: PCollection; { Collection of shapes }
constructor Init(AParent: PWindowsObject; ATitle: PChar);
destructor Done; virtual;
procedure CMNewShape(var Msg: TMessage);
virtual cm_First + cm_NewShape;
procedure CMQuit(var Msg: TMessage);
virtual cm_First + cm_Quit;
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
virtual;
end;
{----- TestApplication methods -----}
{- Initialize TestApplication object's window }
procedure TestApplication.InitMainWindow;
begin
MainWindow := New(PTestWindow, Init(nil, 'Fast Paint Demo'));
Randomize
end;
{----- TestWindow methods -----}
{- Construct TestWindow object }
constructor TestWindow.Init(AParent: PWindowsObject;
ATitle: PChar);
var
I: Integer;
begin
TWindow.Init(AParent, ATitle);
PolyBits := 0; { No bitmap available yet }
PolyShapes := New(PCollection, Init(numShapes, 0));
if PolyShapes = nil then
begin
MessageBox(0, 'Not enough memory available',
'Fata Error', mb_SystemModal);
PostQuitMessage(0)
end;
Attr.Menu := LoadMenu(HInstance, PChar(id_Menu))
end;
{- Dispose of TestWindow object }
destructor TestWindow.Done;
begin
if PolyBits <> 0 then DeleteObject(Polybits);
if PolyShapes <> nil then Dispose(PolyShapes, Done);
TWindow.Done
end;
{- Execute Menu:New Shape command }
procedure TestWindow.CMNewShape(var Msg: TMessage);
var
P: PPolygon;
I: Integer;
R: TRect;
begin
if PolyBits <> 0 then
begin
DeleteObject(PolyBits);
PolyBits := 0
end;
PolyShapes^.Freeall;
GetClientRect(HWindow, R);
for I := 0 to numShapes - 1 do
begin
P := New(PPolygon, Init(50, R.Right, R.Bottom));
if P <> nil then
PolyShapes^.Insert(P)
end;
InvalidateRect(HWindow, nil, true)
end;
{- Execute Menu:Exit command }
procedure TestWindow.CMQuit(var Msg: TMessage);
begin
CloseWindow
end;
{- Paint window's client area, showing current polygons }
procedure TestWindow.Paint(PaintDC: HDC;
var PaintInfo: TPaintStruct);
var
R: TRect;
MemDC: HDC;
OldBitmap: HBitmap;
procedure DrawShape(P: PPolygon); far;
begin
P^.Draw(PaintDC)
end;
begin
if PolyShapes^.Count = 0 then Exit; { Nothing to do }
GetClientRect(HWindow, R);
MemDC := CreateCompatibleDC(PaintDC);
if PolyBits = 0 then
begin {- Draw pattern the "hard" way and create bitmap }
PolyShapes^.ForEach(@DrawShape);
PolyBits:=CreateCompatibleBitmap(PaintDC, R.Right, R.Bottom);
OldBitmap := SelectObject(MemDC, Polybits);
BitBlt(MemDC, 0,0, R.Right, R.Bottom, PaintDC, 0,0, srcCopy)
end else with PaintInfo.rcPaint do
begin {- Redraw pattern the "easy" way using bitmap }
OldBitmap := SelectObject(MemDC, Polybits);
BitBlt(PaintDC, Left, Top, Right, Bottom, MemDC, Left, Top,
srcCopy)
end;
SelectObject(MemDC, OldBitmap);
DeleteDC(MemDC)
end;
var
FastApp: TestApplication;
begin
FastApp.Init('FastApp');
FastApp.Run;
FastApp.Done
end.
{--------------------------------------------------------------
Copyright (c) 1991 by Tom Swan. All rights reserved.
Revision 1.00 Date: 3/26/1991
---------------------------------------------------------------}